# $Id: Gigabase.pm,v 1.1 2008/04/04 11:02:30 knizhnik Exp $
#
#
{
package Gigabase;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $errstr);
require Exporter;
@ISA=qw(Exporter);
$VERSION=1.06;
$errstr=undef;
use Gbcli;

@EXPORT=qw();
my @maybeexported=grep {/^cli/} @Gbcli::EXPORT;
@EXPORT_OK=@maybeexported;
%EXPORT_TAGS=(
 clicodes=>\@maybeexported
);


%Gigabase::errtext=(
 &cli_ok => 'Successful completion',
 &cli_bad_address => 'Invalid format of server URL',
 &cli_connection_refused => 'Connection with server could not be established',
 &cli_bad_statement => 'Text of SQL statement is not correct',
 &cli_parameter_not_found => 'Parameter was not found in statement',
 &cli_unbound_parameter => 'Parameter was not specified',
 &cli_column_not_found => 'No such column in the table',
 &cli_incompatible_type => 'Conversion between application and database type is not possible',
 &cli_network_error => 'Connection with server is broken',
 &cli_runtime_error => 'Error during query execution',
 &cli_closed_statement => 'Invalid statement/session description',
 &cli_unsupported_type => 'Unsupported type for parameter or column',
 &cli_not_found => 'Record was not found',
 &cli_not_update_mode => 'Attempt to update records selected by view only cursor',
 &cli_table_not_found => 'There is no table with specified name in the database',
 &cli_not_all_columns_specified => 'Insert statement doesn\'t specify values for all table columns',
 &cli_not_fetched => 'Fetch method was not called',
 &cli_already_updated => 'Update method was invoked more than once for the same recor'
);
} # package Gigabase

{
package Gigabase::cli_buffer;
use Gigabase;
use Gbcli;
use strict;

sub new{
 my $class=shift;
 my $cmd=shift;
 my $id= shift || 0;
 my $self={'str','','pos',0}; 
 bless ($self,$class);
 $self->put_int(12);
 $self->put_int($cmd);
 $self->put_int($id); 
 return $self;
}
sub reset{
 my ($self,$newbody)=@_;
 $$self{'str'}=$newbody;
 $$self{'pos'}=0;
 return $newbody;
}
sub body {
 my $self= shift;
 return $self->{str};
}
# buffer operations
sub put_data{
 my ($self,$val)= @_;
 $$self{str} .= $val;
}
sub put_int{
 my ($self,$val)= @_;
 $$self{str} .= pack_int($val);
}
sub get_int{
 my $self=shift;
 my $val=unpack_int(substr($self->{str},$self->{pos},4));
 $self->{pos}+=4;
 return $val;
}
sub get_oid{
 my $self=shift;
 my $val=unpack_int(substr($self->{str},$self->{pos},4));
 $self->{pos}+=4;
 return $val; # TODO: new gb_oid() 
}

sub put_oid{
 my ($self,$val)=@_;
 $self->put_int($val);
}

sub put_asciiz{
 my ($self,$val)= @_;
 $$self{str} .= "$val\0"; 
}

sub put_str{
 my ($self,$val)= @_;
 $self->put_int(length ($val)+1);
 $self->put_asciiz($val);
}

sub put_short_str{
 my ($self,$val)= @_;
 $self->put_short(length ($val)+1);
 $self->put_asciiz($val);
}



sub get_asciiz{
 my $self=shift;
 my $str=substr($self->{str},$self->{pos});
 my $retval;
 if ($str=~m/^(.*?)\0/s) {
  $retval=$1;
 }
 else {
  $retval=$str;
 }
 $self->{pos}+=((length $retval)+1);
 return $retval;
}

sub get_str{
 my $self=shift;
 my $len= $self->get_int;
 my $val=substr($self->{str},$self->{pos},$len-1);
 $self->{pos}+=$len;
 return $val;
}
sub get_decimal{
 my $self=shift;
 return $self->get_asciiz;
 #return $self->get_str;
}
sub put_decimal{
 my ($self,$val)=@_;
 $self->put_asciiz($val);
}
sub get_byte{
 my $self=shift;
 return unpack_byte(substr($self->{str},$self->{pos}++,1));
}
sub put_byte{
 my ($self,$val)= @_;
 $$self{str} .= pack_byte($val)
}
sub get_short{
 my $self=shift;
 my $val= unpack_short(substr($self->{str},$self->{pos},2));
 $self->{pos}+=2;
 return $val; 
}
sub put_short{
 my ($self,$val)= @_;
 $$self{str} .= pack_short($val);
}


sub end{
 my ($self)= @_;
 my $len=length $self->{str};
 $self->{len}=$len;
 #$self->put_int(0);
 substr($self->{str},0,4)=pack_int($len);
}

sub get_column_value{
 my ($self)= @_;
 my $t=$self->get_byte();
 if     ($t == cli_bool) { return $self->get_char != '\0' ; }
 elsif ($t == cli_int1)  { return $self->get_byte;}
 elsif ($t == cli_int2) {return $self->get_short;}
 elsif ($t == cli_int4) {return $self->get_int;}
 elsif ($t == cli_oid) { return $self->get_oid; } 
 elsif ($t == cli_real4 or $t == cli_real8 or $t == cli_decimal) 
         { return $self->get_decimal; } 
 elsif ($t == cli_asciiz) { return $self->get_str;}
 elsif ($t == cli_array_of_oid) {
  my $len=$self->get_int;
  my @arr;
  $#arr=$len-1;
  for  (my $i=0;$i<$len;$i++) { $arr[$i]=$self->get_oid();}
  return \@arr;
 }
 elsif ($t == cli_array_of_int1) {
  my $len=$self->get_int;
  my @arr;
  $#arr=$len-1;
  for  (my $i=0;$i<$len;$i++) { $arr[$i]=$self->get_byte();}
  return \@arr;
 }
 elsif ($t == cli_array_of_int2) {
  my $len=$self->get_int;
  my @arr;
  $#arr=$len-1;
  for  (my $i=0;$i<$len;$i++) { $arr[$i]=$self->get_short();}
  return \@arr;
 }
 elsif ($t == cli_array_of_int4) {
  my $len=$self->get_int;
  my @arr;
  $#arr=$len-1;
  for  (my $i=0;$i<$len;$i++) { $arr[$i]=$self->get_int();}
  return \@arr;
 }
 elsif ($t == cli_array_of_decimal or $t == cli_array_of_real4 
        or $t == cli_array_of_real8) {
  my $len=$self->get_int;
  my @arr;
  $#arr=$len-1;
  for  (my $i=0;$i<$len;$i++) { $arr[$i]=$self->get_decimal();}
  return \@arr;
 }
 elsif ($t == cli_array_of_string) {
  my $len=$self->get_int;
  my @arr;
  $#arr=$len-1;
  for  (my $i=0;$i<$len;$i++) { $arr[$i]=$self->get_asciiz();}
  return \@arr;
 }
 else { 
   die "Unsupported type $t\n";
 }
}
# 
# $table - pointer to hash with table description,%
# $columns - used columns,%
# $write_count - if true - do not  write count of columns (for select),$
sub write_column_defs {
 my ($self,$table,$columns,$write_count)=@_;
 my @colnames=keys %$columns;
 if (! $write_count) {
   $self->put_byte(scalar (@colnames)) ; 
 }
 foreach my $name (@colnames) {
  my $type=$$table{$name};
  # if integer
  if ($type == cli_int8) { $type=cli_int4;}
  elsif ($type == cli_real4 or $type==cli_real8) { $type=cli_decimal }
  elsif ($type == cli_array_of_real4 
          or $type == cli_array_of_real8 or $type == cli_array_of_int8) 
          {  $type=cli_array_of_decimal; }
  $self->put_byte($type);
  $self->put_asciiz($name);
 }
 return cli_ok;
}

sub write_column_value{
 my ($self,$t,$val)=@_;
 if    ($t==cli_bool) { $self->put_byte($val ? 1 : 0 );}
 elsif ($t==cli_int1) { $self->put_byte($val);}
 elsif ($t==cli_int2) { $self->put_short($val);}
 elsif ($t==cli_int4) { $self->put_int($val);}
 elsif ($t==cli_oid) { $self->put_int($val); #TODO check if valid reference
 }
 elsif ($t==cli_real4 or $t==cli_real8 or $t==cli_decimal) {
  $self->put_decimal($val);
 }
 elsif ($t==cli_asciiz) { # TODO fix ?!?
  $self->put_str($val);
 }
 elsif ($t==cli_array_of_bool) {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_byte($e ? 1 : 0);
  }
 }
 elsif ($t==cli_array_of_oid) {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_int($e); #TODO ?
  }
 }
 elsif ($t==cli_array_of_int1) {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_byte($e); 
  }
 }
 elsif ($t==cli_array_of_int2) {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_short($e); 
  }
 }
 elsif ($t==cli_array_of_int4) {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_int($e); 
  }
 }
 elsif ($t==cli_array_of_real4 or $t==cli_array_of_real8 
          or $t==cli_array_of_decimal)
 {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_decimal($e); 
  }
 }
 elsif ($t==cli_array_of_string) {
  $self->put_int(scalar @$val);
  foreach my $e (@$val) {
   $self->put_asciiz($e); 
  }
 }
 else {
   die "unsupproted type $t\n";
 }
 return cli_ok;  
}
# $table - types description
# $columns - column values 
sub write_values {
 my ($self,$table,$columns)=@_;
# $self->put_byte(scalar (keys %$columns)) ;
 while (my ($name,$value)=each %$columns) {
  my $type=$table->{$name};
  if ($type == cli_int8) { $type=cli_int4;}
  elsif ($type == cli_real4 or $type==cli_real8) { $type=cli_decimal }
  elsif ($type == cli_array_of_real4 
          or $type == cli_array_of_real8 or $type == cli_array_of_int8) 
          {  $type=cli_array_of_decimal; }
  $self->write_column_value($type,$value);
 }
}

} # end package Gigabase::cli_buffer

{
# Statement
package Gigabase::Statement;
use strict;
use Gigabase;
use Gbcli;


sub new{
 my ($class,$conn,$statstr)=@_;
 $statstr=~s/;\s*$//;# workaround for some guys
 #TODO select from r where name ='%mazay'; not worked
 my $self={'conn',$conn,'statstr',$statstr,'prepared',0,'parameters',{},
   'param_binding',{}};
 bless ($self,$class);
# next release maybe
 my ($k,$v)=each %{$conn->{free_ids}};
 if (!defined $k) { 
  # no more free,get next available
  $self->{id}=++$conn->{n_statements};
  return $self;
  }
 delete $conn->{free_ids}->{$k};
 $self->{id}=$k;
 return $self;
}

sub errcode{
 my $self=shift;
 my $code;
 if (! defined $_[0]){  return $self->{errcode};}
 else { $code=shift;}
 $self->{errcode}=$code; 
 if ($code>=cli_ok) {$self->{errcode}=cli_ok;return 1;}
 else { return undef;}
}

sub errstr(){
 my $self=shift;
 return $Gigabase::errtext{$self->{errcode}};
}
# public fuction for DBI emulation

sub table{
 my $self=shift;
 return $self->{'table'};
} 

sub put_param_value{
 my ($self,$buf,$paramname)=@_;
 my $type=$self->{parameters}->{$paramname};
 my $ref=$self->{param_binding}->{$paramname};
 if ($type==cli_bool) {
  $buf->put_byte($$ref ? 1 : 0);
 }
 elsif ($type==cli_int4) {
  $buf->put_int($$ref);
 }
 elsif ($type==cli_decimal) {
  $buf->put_decimal($$ref);
 }
 elsif ($type==cli_asciiz) {
  $buf->put_asciiz($$ref);
 }
 elsif ($type==cli_oid) {
  $buf->put_oid($$ref);
 }
 else {
  die "user error.Invalid type for parameter $paramname\n";
 }
}

sub fetch{
 my $self=shift;
 my $for_update=shift || 0;
 my $buf;
 my $con=$self->{conn};
 if (! exists $self->{mode}) {$self->{mode}=cli_hash_mode;}
 my $mode=$self->{mode};
 if (! $self->{prepared}) {
   my $table={};
   if (! $self->{table}) { ;
      my $ok=$con->extract_table($self->{statstr},'from',$table);
      if (!$ok) { return $self->errcode($con->errcode)};
      $self->{table}=$table;
   } else {$table=$self->{table};}
   $buf= new Gigabase::cli_buffer(cli_cmd_prepare_and_execute,$self->{id});
   $buf->put_byte(scalar keys %{$self->{parameters}}); # parameters
   # !!!!!!!!!!
   if ($mode == cli_tuple_mode) { 
    $buf->put_byte(scalar (keys %{$self->{columns}})); #binded columns
   }
   else {
    $buf->put_byte(scalar ( keys %$table)); # all columns 
   }
   my $str=$self->{statstr};
   my @paramseq; # sequence ,specially for 'where a>%val and b> %val'
   $str=~s/%(\w+)/
           push @paramseq,$1;
           $self->{parameters}->{$1} ? chr(0) . chr ($self->{parameters}->{$1}) : '';         
         /egx;
   $self->{paramseq}=\@paramseq;
   $buf->put_short_str($str);
   # column names 
    if ($mode == cli_tuple_mode) {
       $buf->write_column_defs($table,$self->{columns},1);
    }elsif ($mode==cli_object_mode or $mode==cli_hash_mode) {
       $buf->write_column_defs($table,$table,1); # all,even if not present in object
    }
   $self->{table}=$table;
   } else {
     $buf=new Gigabase::cli_buffer(cli_cmd_execute,$self->{id}); 
   }
   $buf->put_byte($for_update ? 1 :0 );
   # put parameters value,get names from paramseq
   foreach my $p (@{$self->{paramseq}}) {
    $self->put_param_value($buf,$p);
   }
   #
   $buf->end();
   my $rc=$con->send($buf->body);
   if ($rc!=cli_ok) {
     return $self->errcode($rc); 
   }
   if (!$buf->reset($con->receive(4))) {
            return $self->errcode(cli_network_error); 
   }
   $rc = $buf->get_int();
   if ($rc >= 0) {
       $self->{prepared} = 1;
       $self->{for_update}=$for_update;
       return $rc || '0E0'; # num of rows
   }
   else {
     return $self->errcode($rc); 
   }
}

sub free {
 my $self=shift;
 my $conn=$self->{conn};
 if (! $conn->{opened}) { 
  # connection already closed - die quiet,
  # death of operator not so terrible death :)
  # uncomment this,if you want VERY clean code
  # warn "bad order of free() calls";
 }else { # right order
  if ($self->{prepared}) {
   my $buf = new Gigabase::cli_buffer(cli_cmd_free_statement,$self->{id});
   my $freed_ok=$self->errcode($conn->send($buf->body));
   if (!$freed_ok) {die "free_statement failed"};

# --$self->{conn}->{n_statements};

   if (! exists  $conn->{free_ids}->{$self->{id}}) {
     $conn->{free_ids}->{$self->{id}}=1;
   }else {
    die "Twice free of statement.";
   }

  }
 }
 $self->{conn}=undef;
 $self->{prepared}=undef;
 return 1;
}

sub read_bind_hash{
 my ($self,$hashref)=@_;
 my %chash=%{$self->{table}};
 while (my ($name,$val)=each %chash) {
  $self->{record}->{$name}=$hashref->{$name};
 }
}
# external values to internal
sub read_bind{
 my $self=shift;
 my $mode=$self->{mode};
 if (defined $mode and $mode == cli_tuple_mode) {
  # type strict mode !
  my %chash=%{$self->{columns}};
  while (my ($name,$ref)= each %chash) {
   my $tryclass=ref $ref;
   my $realclass=ref $self->{record}->{$name};
   if ($tryclass) {
      if ($tryclass eq 'ARRAY' and $realclass eq 'ARRAY') {
        @{$self->{record}->{$name}}=@{$ref};
      }
      else {
        $self->{record}->{$name}=$$ref;
      };
   }
   else {
     return $self->errcode(cli_incompatible_type);
     #die "bind to not a reference\n";
   }
  }  # while
 } 
 elsif ($mode == cli_object_mode) {
  #if ( ($self->{tablename} eq ref ${$self->{obj}}) or ($self->{obj_rename})) { 
  if ($self->{obj_rename} or ${$self->{obj}}->isa($self->{tablename})){
    $self->read_bind_hash(${$self->{obj}}); 
  }
  else {
     return $self->errcode(cli_incompatible_type);
  }
 }
 elsif ($mode == cli_hash_mode) { 
  $self->read_bind_hash($self->{hash});
 } # else:  no bindings - no problems :)
}
sub write_bind_hash{
 my ($self,$hashref)=@_;
 my %chash=%{$self->{record}};
 while (my ($name,$val)=each %chash) {
  $hashref->{$name}=$val;
 }
}
# internal values to external
sub write_bind{
 my $self=shift;
 my $mode=$self->{mode};
 if ($mode == cli_tuple_mode) {
  # type strict mode !
  my %chash=%{$self->{columns}};
  while (my ($name,$ref)= each %chash) {
   my $tryclass=ref $ref;
   my $realclass=ref $self->{record}->{$name};
   if ($tryclass) {
      if ($tryclass eq 'ARRAY' and $realclass eq 'ARRAY') {
        @{$ref}=@{$self->{record}->{$name}};
      }
      else {
        $$ref=$self->{record}->{$name};
      };
   }
   else {
     return $self->errcode(cli_incompatible_type);
     #die "bind to not a reference\n";
   }
  }  # while
 } 
 elsif ($mode == cli_object_mode) {
  if ($self->{obj_rename} or ${$self->{obj}}->isa($self->{tablename})){
    $self->write_bind_hash(${$self->{obj}}); 
  }
  else {
   return $self->errcode(cli_incompatible_type);
   #die "bind to uncompatible object type\n";
  }
 }
 elsif ($mode == cli_hash_mode) { 
  $self->write_bind_hash($self->{hash});
 }
}


sub get_record {
 my ($self,$cmd)=@_;
 if (!$self->{conn}) {
       return $self->errcode(cli_closed_statement);
 }
 if (!$self->{prepared}) {
       return $self->errcode(cli_not_fetched);
 }
 my $buf = new Gigabase::cli_buffer($cmd, $self->{id});
 my $rc = $self->{conn}->send($buf->body);
 if ($rc != cli_ok) {
       return $self->errcode($rc);
 }
 if (! $buf->reset($self->{conn}->receive(4))) {
       return $self->errcode(cli_network_error);
 }
 my $len = $buf->get_int();
 if ($len <= 0) {
       return $self->errcode($len);
 }
 if (! $self->{record}) {$self->{record}={};}
 $buf->reset($self->{conn}->receive($len-4));
 $self->{oid}=$buf->get_int();
 if ($self->{oid} == 0) {
       $self->{oid}=undef;
       return $self->errcode(cli_not_found); # like EOF
 }
 #foreach (keys %{$self->{table}} ) {
 foreach (keys %{$self->{columns}} ) {
  my $val=$buf->get_column_value();
 # print "$_ = ";
  my $ref=ref $val;
 # if ($ref eq 'ARRAY') { print "(",join( ',',(@$val)),")";}
 # else { print "$val";}
 # print "\n";
  $self->{record}->{$_}=$val;
 }   
 $self->{updated}=0;
 $self->write_bind();
 return 1;
} # get_record

    sub get_first {
        my $self=shift; 
        return $self->get_record(cli_cmd_get_first);
    }
    sub get_last {
        my $self=shift; 
        return $self->get_record(cli_cmd_get_last);
    }
    sub get_next {
        my $self=shift; 
        return $self->get_record(cli_cmd_get_next);
    }
    sub get_prev {
        my $self=shift; 
        return $self->get_record(cli_cmd_get_prev);
    }

    sub get_oid {
     my $self=shift; 
        if ($self->{oid}) { 
         # return new gb_reference($self->curr_oid);
         return $self->{oid};
        }
     return undef;
    }

sub fetchrow_hashref{
 my $self=shift;
 my $savemode=$self->{mode};
 $self->{mode}=cli_hash_mode;
 my %h;
 my $savehash=$self->{hash};
 $self->{hash}=\%h;
 my $ok=$self->get_next;
 $self->{hash}=$savehash;
 $self->{mode}=$savemode;
 if ($ok) {
   return \%h;
 } else { 
  return undef;
 }
}
#
sub findtablename{
 my ($self,$keyword)=@_;
 if (!($self->{statstr}=~/$keyword\s+(\w+)/i)) {
  die "Failed to extract tablename from query\n";
 }
 return $1;
}

# insert  helper
sub do_insert{
  my ($self)=@_;
  if (! $self->{conn}) {
    return $self->errcode(cli_closed_statement);
  }
  my $con=$self->{conn};
   my $table={};
   if (! $self->{table}) {
    my $ok=$con->extract_table($self->{statstr},'into',$table);
    if (!$ok) { return $self->errcode($con->errcode)};
    $self->{table}=$table; 
   }
   else { $table=$self->{table};}
   my $buf=new Gigabase::cli_buffer(cli_cmd_prepare_and_insert,$self->{id});
   $buf->put_asciiz($self->{statstr});
  # must write only that presents in {record} !
   my $rc=$buf->write_column_defs($table,$self->{record});
   if ($rc != cli_ok) { return $self->errcode($rc);}
   $buf->write_values($table,$self->{record});
   $buf->end();
   $rc=$con->send($buf->body);
   if ($rc!=cli_ok) { return $self->errcode($rc);}
  # new protocol with rowid,gigabase < 2.49 send 8 bytes here
   if (! $buf->reset($self->{conn}->receive(12))) {
     return $self->errcode(cli_network_error);
   }
   $rc=$buf->get_int;
   my $oid;
   my $rowid;
   if ($rc==cli_ok) {
     $rowid=$buf->get_int;
     $oid=$buf->get_int;
     if ($oid !=0) {
      # TODO reference class
      $self->{oid}=$oid;
      $self->{rowid}=$rowid;
     }
     else {
      $oid=undef;
     }
    return $oid;
   }
   else {
    return $self->errcode($rc);
   }
} # do_insert 

# update_helper
# write values in {record} to database
sub do_update{
 my ($self)=@_;
 if (! $self->{conn}) {return $self->errcode(cli_closed_statement);}
 if (! $self->{prepared}) {return $self->errcode(cli_not_fetched);}
 if (! $self->{oid}) {return $self->errcode(cli_not_found);}
 if (! $self->{for_update}) {return $self->errcode(cli_not_update_mode);}
 if ( $self->{updated}) {return $self->errcode(cli_already_updated);}
 
 my $buf=new Gigabase::cli_buffer(cli_cmd_update,$self->{id});
# !!
 $buf->write_values($self->{table},$self->{record});
# !!
 $buf->end();
 my $rc=$self->{conn}->send($buf->body);
 if ($rc != cli_ok) {
      return $self->errcode($rc);
 }
 $self->{updated} = 1;
 if (!$buf->reset($self->{conn}->receive(4))) {
        return cli_network_error;
 }
 $rc=$buf->get_int();
 if ($rc==0) {return 1;}
 else {return $self->errcode($rc);}
}
sub update{
 my $self=shift;
 $self->read_bind();
 return $self->do_update();
}

#
#   Bind column of select or insert statement
#

sub bind_column{
 my ($self,$name,$ref)=@_;
 if (!$self->{conn}) { return $self->errcode(cli_closed_statement);}
 $self->{prepared}=0;  
 if (! exists $self->{columns}) {$self->{columns}=();}
 $self->{columns}->{$name}=$ref;
 $self->{mode}=cli_tuple_mode;
 $self->{obj}=undef;
 $self->{hash}=undef;
 return 1;
}
sub bind_object{
 my ($self,$objref,$renamed)=@_;
 if (!$self->{conn}) { $self->errcode(cli_closed_statement);}
 if (defined $self->{mode} and $self->{mode}==cli_tuple_mode) {$self->{prepared}=0; }
 $self->{obj_rename}=$renamed;
 if (!$renamed) { $self->{tablename}=ref $$objref;}
 $self->{obj}=$objref;
 $self->{columns}=undef;
 $self->{hash}=undef;
 $self->{mode}=cli_object_mode;
 return 1;
}

sub bind_hash{
 my ($self,$hashref)=@_;
 if (!$self->{conn}) { return $self->errcode(cli_closed_statement);}
 if ($self->{mode}==cli_tuple_mode) {$self->{prepared}=0; }
 $self->{hash}=$hashref;
 $self->{obj}=undef;
 $self->{columns}=undef;
 $self->{mode}=cli_hash_mode;
 return 1;
}

sub bind_parameter{
 my ($self,$name,$paramref,$type)=@_;
 return undef if ( ! ref $paramref); # TODO
 $self->{prepared}=0; 
 if (! defined $type) { # try auto-identify type
   local $_=$$paramref;
   if (/^-?\d+$/) { $type=cli_int4;} 
   elsif( /^-?\d+\.\d+$/) {$type=cli_decimal;}
   elsif( /^-?\d\.\d+e[+-]\d+$/i) {$type=cli_decimal;}
   else {$type=cli_asciiz;}
   # TODO class references !
 }
 elsif ($type==cli_real4 or $type==cli_real8) 
           { $type=cli_decimal;}
 $self->{parameters}->{$name}=$type;
 $self->{param_binding}->{$name}=$paramref;
 return 1; 
}

# remove selected rows
sub remove() {
  my $self=shift;
  if (!$self->{conn}) {
         return $self->errcode(cli_closed_statement);
  }
  if (!$self->{prepared}) {
         return $self->errcode(cli_not_fetched);
  }
  if (!$self->{for_update}) {
         return $self->errcode(cli_not_update_mode);
  }
  my $rc=$self->{conn}->send_receive(cli_cmd_remove, $self->{id});
  return $self->errcode($rc);
}

# insert using binded values 
sub insert{
 my $self=shift;
 my $con=$self->{conn};
 if (! $self->{table}) {
    my $table={};
    my $ok=$con->extract_table($self->{statstr},'into',$table);
    if (!$ok) { return $self->errcode($con->errcode)};
    $self->{table}=$table; 
   }
 $self->{tablename}=$self->findtablename('into');
 $self->read_bind;
 $self->do_insert;
}

sub DESTROY {
 my $self=shift;
 if ($self->{conn}) {$self->free;}
 1;
}

} # end package Statement

{
# Connection
#
package Gigabase::Connection;
use strict;
use Gigabase;
use Gbcli;

use IO::Socket;

sub errcode{
 my $self=shift;
 my $code;
 if (! defined $_[0]){  return $self->{errcode};}
 else { $code=shift;}
 $self->{errcode}=$code;
 if ($code>=cli_ok) {$self->{errcode}=cli_ok;return 1;}
 else { return undef;}
}

sub errstr(){
 my $self=shift;
 return $Gigabase::errtext{$self->errcode};
}

# constructor 
sub new{
 my ($class,$host,$port,$user,$password)=@_;
 my $self={'host',$host,'port',$port,'user',$user,'password',$password};
 bless ($self,$class);
 my $socket=IO::Socket::INET->new(
            PeerAddr=>$host,
            PeerPort=>$port,
            Proto=>'tcp'
         );
# unix version of GigaBASE listen on both sockets
# then this code not used now.
# my $socket=IO::Socket::UNIX->new(
#           Type=>SOCK_STREAM,
#           Peer=>"/tmp/$host:$port"
#         ); 
 if (!defined($socket)) { $Gigabase::errstr="Couldn't connect : $@\n";return undef;} 
 $socket->autoflush(1);
 $$self{sock}=$socket;
 my $buf=new Gigabase::cli_buffer(cli_cmd_login);
 $buf->put_asciiz($user);
 $buf->put_asciiz($password);
 $buf->end();
 $self->send($buf->body); 
 my $response=$self->receive(4);
 my $rc=unpack_int($response);
 if ($rc==cli_ok) {
#  $$self{n_statements}=0;
  $$self{opened}=1;
  $$self{descr_cache}={}; #here stored refs of pairs (2 array refs)
  return $self;
 }
 else {
  $self->{sock}->close;
  return $self->errcode($rc);
 }
}

sub send{
 my ($self,$data)=@_;
 my $num=($self->{sock})->syswrite($data,length $data);
 #my $num=($self->{sock})->send($data);
 return ($num == length($data)) ? cli_ok :cli_network_error;
}

sub receive{
 my ($self,$num)=@_;
 my $buf='';
 my $sock=$self->{sock};
 my $rcvd=($self->{sock})->sysread($buf,$num);
 return ($rcvd==$num) ? $buf:undef;
}

sub send_receive{
 my ($self,$cmd,$stmt_id)=@_;
 $stmt_id=0 unless defined($stmt_id);
 my $buf = new Gigabase::cli_buffer($cmd,$stmt_id);
 my $rc = $self->send($buf->body);
 if ($rc == cli_ok) {
        my $response = $self->receive(4);
        if (!$response) {
             return cli_network_error;
        }
    return unpack_int($response);
 }
 return $rc;
}

sub close {
 my $self=shift;
   if (!$self->{opened}) {
       return $self->errcode(cli_closed_connection);
   }
  $self->commit;
  my $buf=new Gigabase::cli_buffer(cli_cmd_close_session);
  $buf->end();
  my $rc=$self->send($buf->body); 
  $self->{opened} = 0;
  $self->{sock}->close;
  return $self->errcode($rc);
}

sub commit() {
    my $self=shift;
     if (!$self->{opened}) {
         return $self->errcode(cli_closed_connection);
     }
   return $self->errcode($self->send_receive(cli_cmd_commit));
}

sub rollback() {
    my $self=shift;
    if (!$self->{opened}) {
         return $self->errcode(cli_closed_connection);
    }
    return $self->errcode($self->send_receive(cli_cmd_abort));
}

sub precommit() {
    my $self=shift;
     if (!$self->{opened}) {
         return $self->errcode(cli_closed_connection);
     }
   return $self->errcode($self->send_receive(cli_cmd_precommit));
}

sub show_tables {
 my ($self,$tables)=@_;
 my $buf = new Gigabase::cli_buffer(cli_cmd_show_tables);
  my  $rc = $self->send($buf->body);
      if ($rc != cli_ok) {
          return $self->errcode($rc);
     }
     if (!$buf->reset($self->receive(8))) {
         return $self->errcode(cli_network_error);
     }
     my $len = $buf->get_int();
     my $n_tables = $buf->get_int();
     if ($n_tables == -1) {
          return $self->errcode(cli_table_not_found);
     }
     my $response = $self->receive($len);
       if (!$response) {
         return $self->errcode(cli_network_error);
     }
    my @arr=split '\0',$response;
    @$tables=@arr;
    return 1;
}
 

sub create_statement {
 my ($self,$stmnt_body)=@_;
 my $st=new Gigabase::Statement($self,$stmnt_body);
 return $st;
}

sub extract_table{
# $keyword , \%table
 my ($self,$query,$keyword,$table)=@_;
 if (!($query=~/$keyword\s+(\w+)/i)) {
   #gb_trace("Failed to locate keyword $keyword in query $query");
   #           return cli_bad_statement;
  die "Failed to extract tablename from $query\n";
 }
 my $tablename=$1;
 #$self->{tablename}=$tablename;
 return $self->describe_table($tablename,$table);
}

sub describe_table{
 my ($self,$tablename,$table)=@_;
 my $desc=[];
 my ($names,$types)=$self->describe_table_2arrays($tablename);
 return undef unless $names;
 for (my $i=0;$i<scalar @$names;$i++) {
  $table->{$names->[$i]}=$types->[$i];
 }
 return 1;
}

sub describe_table_2arrays{
 my ($self,$tablename)=@_;
 my $description=$self->{'descr_cache'}->{$tablename};
 if ($description) {
  return ($description->[0],$description->[1]); 
 }
 my $buf=new Gigabase::cli_buffer(cli_cmd_describe_table);
 $buf->put_asciiz($tablename);
 $buf->end();
 my $rc=$self->send($buf->body);
 if ($rc != cli_ok) {
  return $self->errcode($rc);
 }
 if (! $buf->reset($self->receive(8))) {
      return $self->errcode(cli_network_error);
 }
 my $len=$buf->get_int();
 my $n_columns=$buf->get_int();
 if ($n_columns == -1) {
      return $self->errcode(cli_table_not_found);
 }
 my $response = $self->receive($len);
 if ( ! $response ) {
      return $self->errcode(cli_network_error);
 }
 my (@types,@names);
 # assumes that no 0 values as type id
  my @arrs=split /\0/,$response;
  map { 
    my $typeid = $buf->get_byte();
    my $flags = $buf->get_byte();
    my $colname = $buf->get_asciiz();
    my $reftablename = $buf->get_asciiz();
    my $inverserefname = $buf->get_asciiz();
#    my ($typeid,$colname)=/^(.)(.+)$/s;
#    $typeid=unpack_byte($typeid);
    push (@names,$colname);
    push (@types,$typeid);
  } @arrs;
  $self->{'descr_cache'}->{$tablename}=[\@names,\@types];
  return (\@names,\@types); 
}


sub data_from_hash{
 my ($self,$tablename,$obj)=@_;
 my $table={};
 $self->describe_table($tablename,$table); 
 my $statm=$self->create_statement("insert into $tablename");
 my $record={};
 foreach (keys %$obj) {
  if (exists $table->{$_}) {
    $record->{$_}=$obj->{$_};
  }
 }
 $statm->{record}=$record;
 $statm->{table}=$table;
 my $oid=$statm->do_insert;
 $statm->free; 
 $self->errcode($statm->errcode()) unless ($oid);
 return $oid;
}

sub insert_record{
 my ($self,$tablename,$rec)=@_;
 return $self->data_from_hash($tablename,$rec);
}

sub insert_object{
 my ($self,$obj)=@_;
 # TODO: work with Class::Struct standart package
 my $tablename=ref $obj;
 return $self->data_from_hash($tablename,$obj);
}

sub DESTROY{
 my $self=shift;
 if ($self->{sock}) { 
  $self->close;
 }
}

} # end package Connection

{
package Gigabase::ConnectionPool;

sub new{
 my $class=shift;
 my $self={'pool',[]};
 bless ($self,$class);
 return $self;
}

sub get {
 my ($self,$host,$port,$user,$password)=@_;
 foreach my $e (@{$self->{pool}}) {
  if (($e->{host} eq $host) && ($e->{port}==$port) && 
      ($e->{user} eq $user) && ($e->{password} eq $password)) {
   return $e;  
  }
 }
 return new Gigabase::Connection($host,$port,$user,$password);
}

sub free {
 my ($self,$conn)=@_;
 $conn->commit();
 push @{$self->{pool}},$conn;
}

sub close {
 my $self=shift;
 foreach my $e (@{$self->{pool}}) {
   $e->close;
  }
 return new Gigabase::Connection($host,$port,$user,$password);
}

sub DESTROY {
 my $self=shift;
 $self->close;
}

}# end package ConnectionPool

1;
__END__;

=head1 NAME

Gigabase - Perl extension for GigaBASE Object-Relational database system

=head1 SYNOPSIS

 use Gigabase;

 my $con=new Gigabase::Connection('localhost',6100,'guest','guest')
   || die "$Gigabase::errstr\n";

 my $statm=$con->create_statement('select * from r') 
   || die "$con->errstr\n";
 my $typles=$statm->fetch();
 ...
 $con->commit;
 $con->close();


=head1 DESCRIPTION

=head2 STYLE

 All methods returns undef on error.It's traditional way for Perl.
Error code can be retrieved by B<errcode> method for mostly all objects.
This not same as PHP interface style with returning error code anywhere.
For using error codes you should export it:

 use Gigabase qw(:clicodes);

=head1 CLASSES

=head2 Gigabase::Connection

This class is responsible for establishing connection with the database
and session specific operations.Destructor automatically L<commit>
transaction and free resources used by server.


=over 2

=item B<new>

Connect to a database with parameters, use the 
following syntax: 

 $con=new Gigabase::Connection('localhost',6100,'guest','password');

This connects to the CLI GigaBASE server running at B<localhost> host,
6100 port,as user "guest", with the password "password". 
Constructor returns undef if can't create connection 
and set global variable B<$Gigabase::errstr> as error description.

=item B<create_statement>

  my $statement=$con->create_statement('select * from r') 
      || die "$con->errstr\n";

Creates L<"Gigabase::Statement"> object with specified SubSQL statement
Returns object or undef on error.Error explained by B<errcode> 
or B<errstr> method of L<connection|"Gigabase::Connection">.

=item B<insert_object>

 $con->insert_object($object);

 Insert object to database,get column values from exemplar fields.
Return OID of inserted object or undef on error.
Name of table gets from class name of object.Currently GigaBASE 
do not support class names with '::' characters.
Maybe it changes in future versions.
Table must exists.Creation can be done by B<subsql> utility.

=item B<insert_record>

 $con->insert_record($classname,\%hash);

Insert record to table $classname,get column values from 
hash reference.Return OID of inserted object or undef on error.
Table must exists.Creation can be done by B<subsql> utility.

=item B<commit>

  $con->commit();

Commit database transaction.

=item B<precommit>

  $con->precommit();

Causes a precommit operation on database transaction.
Do not write data to disk,commit it in memory.

=item B<rollback>

  $con->rollback();

Rollback database transaction.

=item B<show_tables> 

 $con->show_tables(\%hash);

Write names of tables stored in database into hash.

=item B<describe_table>

 $con->describe_table('name',\%hash);

Write description of table into hash.Each pair contains name of 
column and type.Type is one of cli constants.
See L<EXPORT> section to details.

=item B<close>
 
 $con->close();

Close connection to the server.Causes a L<commit> operation.

=item B<errcode>

 $con->errcode();

Code of error.Available codes can be exported into application.
See L<EXPORT> section to details.

=item B<errstr>
 
 $con->errstr()

Text message explains last error.

=back 


=head2 Gigabase::Statement

This class represents prepared statement. Statement can be used several
time with different parameters values. Destructor automatically free 
server resources used by object.Parameters available into statement body.
Parameter name should start with '%'.

=over 2

=item B<new>

 $statement=new Gigabase::statement($connection,'select * from r');

Creates L<"Gigabase::Statement"> object with specified SubSQL statement
Returns object or undef on error.Error explained by B<errcode> 
or B<errstr> method of L<connection|"Gigabase::Connection">.

=item B<fetch>

 $statement->fetch($for_update)

Execute select statement.
$for_update - true value if fetched rows will be updated,
by using L<update> method.

=item B<fetchrow_hashref>
 
 $hashref=$statement->fetchrow_hashref();
 print $hashref->{fieldname};

 Fetch row of selection,returns hash reference.
 If no more rows returns undef.
 This method similar to B<DBI> interface.

=item B<update>
 
 $statement->update();

 Update the current row in the selection. You have to set
 for_update parameter of fetch to true in order to be 
 able to perform  updates. Updated value of row fields 
 will be taken from bound column variables.

=item B<remove>
 
 $statement->remove();

 Remove all selected records. You have to set for_update parameter
 of fetch to 1 in order to be able to remove records.

=item B<bind_column>

 $statement->bind_column('column',\$variable);

 Bind column of select or insert statement.

=item B<bind_object>

 $statement->bind_object(\$object); 

 Bind variable to receive fetched object or to specify inserted
 object.

=item B<bind_hash>

 $statement->bind_hash(\%hash);

 Bind variable for fetching or inserting record as associative
 array of pairs ( field, value ).

=item B<get_first>
 
 $statement->get_first();

Get first row of the selection.

=item B<get_last>

 $statement->get_last();

Get last row of the selection.

=item B<get_next>

 $statement->get_next();

Get next row of the selection. If get_next records is called
exactly after L<fetch> method call, is will fetch the first record in
the selection.

=item B<get_prev>

 $statement->get_prev();

Get previous row of the selection. If get_next records is called
exactly after fetch method call, is will fetch the last record in
selection.

=item B<get_oid>

 $statement->get_oid();

Get object identifier of the current record.

=item B<bind_parameter>

 $statemen->bind_parameter('paramname',\$paramvar);

Bind parameter to the statement.

=item B<errcode>

 $statement->errcode();
 
Code of error.Available codes can be exported into application.
See L<EXPORT> section to details.

 use Gigabase qw(:clicodes);

=item B<errstr>        

 $statement->errstr();

Text message explains last error.

=back

=head2  Gigabase::ConnectionPool

 This class can be used for connection pooling. Some application (for
 example Web server scripts) has to open database connections multiple
 times. To eliminate overhead of establishing connection each time
 client request is proceeded, connection pool can be used. In this case
 connection is not actually closed, but instead of it just placed in
 the connection pool. Next time the connection with this server with
 the same user name and password is established, connection is just
 extracted from the pool.

=over 2

=item B<new> 

 my $pool=new Gigabase::ConnectionPool;

 Constructor. 


=item B<get>

 my $connection=$pool->get($host,$port,$user,$password);

 Reuse existed pooled connection or make new one.

=item B<free> 

 $pool->free($connection);

 Place connection in the connection pool to make it available
 for future reuse. This method implicitly commits the last
 transaction performed by the specified connection.

=item B<close>

 $pool->close();
 
 Physically close all connections in the connection pool.

=back


=head1 EXPORT

By default,no at all.
cli_ok and other cli constants, same as GigaBASE, can be exported
into application name space by using module with tag 'clicodes'.

 use Gigabase qw(:clicodes);

=head1 EXAMPLE

# This example requires table r 
# create table r (name string,one real4,two real8,three int4);
 use strict;
 use Gigabase;

 my $con=new Gigabase::Connection('localhost',6100,'guest','guest')
   || die "$Gigabase::errstr\n";
 {
  my $statm=$con->create_statement('select * from r') 
    || die "$con->errstr\n";
  my ($name,$one,$two,$three);
  $statm->bind_column("name",\$name);
  $statm->bind_column("one",\$one);
  $statm->bind_column("two",\$two);
  $statm->bind_column("three",\$three);
  my $typles=$statm->fetch();
  die $statm->errstr unless defined($typles);
  print "num of tuples " , $typles ,"\n";
  while ($statm->get_next()) {
   print "name=$name one=$one two=$two three=$three\n";
  }
 } #statement automatically freed
 $con->commit;
 $con->close();

=head1 AUTHOR

Pavel Zheltouhov I<pavlo@stud.vsu.ru>,I<pavlo@tvrn.ru>

=head1 COPYRIGHT

The Gigabase module is a free software. 
You may distribute under the terms of the GNU Artistic License,
as specified in the Perl README file.

=head1 RELEASE NOTES

 You sholud use gigabase version greater than 2.41.
 This version developed on Perl 5.6.0 running Linux on x86 PC.
 Tested on:
  Win32 Perl version 5.005_03 ActiveState build 515.
  Sun OS 5.8 sun4u  Perl version  5.005_03 
  FreeBSD 4.0-RELEASE x86 Perl version 5.005_03
 Pure Perl code does not require even C compiler to install.

=head1 BUGS

 Not known.

=head1 SEE ALSO

GigaBASE homepage at http://www.ispras.ru/~knizhnik/gigabase.html

=cut
